home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel-075.lha
/
feel0.75
/
Src
/
interpret.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-06-18
|
9KB
|
393 lines
/*
* Bytecode Interpreter for Feel
*/
#ifdef BCI
#include <stdio.h>
#include "defs.h"
#include "structs.h"
#include "funcalls.h"
#include "global.h"
#include "ngenerics.h"
#include "modules.h"
#include "bvf.h"
#include "allocate.h"
#include "modboot.h"
#include "error.h"
/* Definition of the bytecodes */
#define COUNT_BYTES /* ---- I want to see what goes on... */
#include "iset.h"
#include "interpret.h"
#include "bytecodes.h"
/* classes */
static LispObject ByteFunction_Class;
static LispObject ByteFunction;
/* Boot Modules */
#define MAX_BOOT_MODULES 50
BC_GLOBALS()
/* Function that returns to 'c' */
static LispObject Cb_generic_lookup;
/* Interface from the world */
LispObject compute_and_apply_method();
LispObject call_method();
LispObject module_apply_args();
/* The biggie */
LispObject interpret_bytes(LispObject *stacktop, bytecode *start_pc, int context)
{
/* locals for a few specials */
LispObject BCtrue=lisptrue;
LispObject BCnil=nil;
LispObject BC_globals;
bytecode *pc;
LispObject *sp;
int this_vector;
BC_INITIALISE_GLOBALS();
while (TRUE)
{
BC_PRESWITCH();
switch(*(pc++))
{
BC_CASE(BC_NOP);
/* Globals, etc */
BC_CASE(BC_PUSH_GLOBAL);
BC_CASE(BC_SET_GLOBAL);
BC_CASE(BC_PUSH_STATIC);
BC_CASE(BC_PUSH_FIXNUM);
BC_CASE(BC_SET_STATIC);
BC_CASE(BC_PUSH_SPECIAL);
/* stack refs */
BC_CASE(BC_PUSH_NTH);
BC_CASE(BC_SET_NTH);
/* Stack abuse */
BC_CASE(BC_SLIDE_STACK);
BC_CASE(BC_SWAP);
BC_CASE(BC_DROP);
/* env reference */
BC_CASE(BC_ENV_REF);
BC_CASE(BC_SET_ENV);
BC_CASE(BC_POP_ENV);
BC_CASE(BC_MAKE_ENV);
/* object reference */
BC_CASE(BC_VREF);
BC_CASE(BC_SET_VREF);
BC_CASE(BC_SLOT_REF);
BC_CASE(BC_SET_SLOT);
BC_CASE(BC_SET_TYPE);
/* Leaping merrily */
BC_CASE(BC_BRANCH);
BC_CASE(BC_BRANCH_NIL);
/* Calling things */
BC_CASE(BC_APPLY_ANY);
BC_CASE(BC_APPLY_BVF);
BC_CASE(BC_APPLY_METHODS);
BC_CASE(BC_PUSH_LABEL);
/* and return */
BC_CASE(BC_RETURN);
/* real return */
BC_CASE(BC_EXIT);
/* allocation */
BC_CASE(BC_CONS);
BC_CASE(BC_ALLOC_CLOSURE);
/* Tests */
BC_CASE(BC_NULLP);
BC_CASE(BC_EQP);
BC_CASE(BC_CONTEXT);
BC_NOINSTRUCT(*(pc-1));
}
Cb_generic_lookup=BCnil;
}
/* not ever */
return nil;
}
/* Returns a closure which will execute from 0 */
/* It is vital that the vector is not GC'd */
EUFUN_3(Fn_add_codevector,bytes,len, posn)
{
LispObject new_closure;
LispObject ptr;
int i,lim=intval(len);
bytecode *space;
space=(bytecode *)allocate_space(stacktop,lim);
ptr=bytes;
for (i=0; i<lim ; i++)
{
if (!is_fixnum(CAR(ptr)))
CallError(stacktop,"add codevector: bad byte",CAR(ptr),NONCONTINUABLE);
if (intval(CAR(ptr))>255)
CallError(stacktop,"add codevector: bad byte number",CAR(ptr),NONCONTINUABLE);
space[i]=(bytecode)intval(CAR(ptr));
ptr=CDR(ptr);
}
new_closure=allocate_instance(stacktop,ByteFunction);
lval_typeof(new_closure)=TYPE_B_FUNCTION;
bytefunction_offset(new_closure)=allocate_integer(stacktop,0);
bytefunction_nargs(new_closure)=allocate_integer(stacktop,0);
bytefunction_env(new_closure)=nil;
bytefunction_codenum(new_closure)=posn;
bytevectors[intval(posn)]=space;
return new_closure;
}
EUFUN_CLOSE
#define BUFSIZE 1024
EUFUN_1(Fn_load_bytecodes,name)
{
char buf[BUFSIZE];
FILE *file;
bytecode *code;
int nslots,nbytes,i;
LispObject slotvector,*slots;
sprintf(buf,"%s.ebc",stringof(name));
file=fopen(buf,"r");
if (file==NULL)
CallError(stacktop,"Could not open file\n",name,NONCONTINUABLE);
fgets(buf,BUFSIZE,file);
if (strcmp(buf,"ASCIIBYTES\n")==0)
{
fgets(buf,BUFSIZE,file);
nslots=atoi(buf);
fgets(buf,BUFSIZE,file);
nbytes=atoi(buf);
code=(bytecode *) allocate_space(stacktop,nbytes);
bytevectors[SYSTEM_GLOBAL_VALUE(static_count)]=code;
slotvector=allocate_static_vector(stacktop,sizeof(LispObject)*nslots);
statics[SYSTEM_GLOBAL_VALUE(static_count)]=slotvector;
slots= &(vref(slotvector,0));
fprintf(stderr,"code: %x[%d] slots: %x[%d]\n",code,nbytes,slots,nslots);
STACK_TMP(slotvector);
for (i=0 ; i<nbytes ; i++)
{
if (fgets(buf,BUFSIZE,file)==NULL)
perror("fgets");
code[i]=(bytecode) (atoi(buf));
}
fclose(file);
}
else
{
fprintf(stderr,"%s\n",buf);
CallError(stacktop,"Unknown format: %s\n",nil,NONCONTINUABLE);
}
/* Load the statics --- should be done in lisp but what the hell... */
sprintf(buf,"%s.est",stringof(name));
file=fopen(buf,"r");
if (file==NULL)
CallError(stacktop,"load-bytecodes: no file",nil,NONCONTINUABLE);
else
{
extern LispObject Fn_Lex_Yacc_reader(LispObject*,FILE *);
LispObject new;
new=Fn_Lex_Yacc_reader(stacktop,file);
nslots=intval(new);
for (i=0; i<nslots ; i++)
{
new=Fn_Lex_Yacc_reader(stacktop,file);
vref(statics[SYSTEM_GLOBAL_VALUE(static_count)],i)=new;
}
fclose(file);
}
/* Allocate a new closure and interpret it. */
{
LispObject apply_nary_bytefunction(LispObject *, int, LispObject);
LispObject new_closure;
new_closure=allocate_instance(stacktop,ByteFunction);
lval_typeof(new_closure)=TYPE_B_FUNCTION;
bytefunction_offset(new_closure)=allocate_integer(stacktop,0);
bytefunction_nargs(new_closure)=allocate_integer(stacktop,0);
bytefunction_env(new_closure)=nil;
bytefunction_codenum(new_closure)=allocate_integer(stacktop,SYSTEM_GLOBAL_VALUE(static_count));
SYSTEM_GLOBAL_VALUE(static_count)++;
return(apply_nary_bytefunction(stacktop,0,new_closure));
}
}
EUFUN_CLOSE
EUFUN_2(Fn_set_module_statics,module,n)
{
int i;
i=intval(n);
module->C_MODULE.values=statics[i];
return nil;
}
EUFUN_CLOSE
LispObject apply_nary_bytefunction(LispObject *stackbase, int nargs, LispObject fn)
{
bytecode *start;
int this_vector; /* to make reify do the business */
LispObject rfn;
int i;
if (is_cons(fn))
rfn=method_function(CAR(fn));
else
rfn=fn;
/* move the arguments up a little --- top first */
for (i=nargs-1; i>=0 ; i--)
*(stackbase+i+2)= *(stackbase+i);
/* Place the exit function in the return address */
this_vector=0;
start=exit_bytes;
*(stackbase+1)=REIFY_PC(start);
/* Work out where to start (also updates this_vector)*/
start=BF2PC(rfn);
/* hack fn slot */
*stackbase=fn;
*(stackbase+nargs+2)=bytefunction_env(rfn);
return(interpret_bytes(stackbase+nargs+3,start,this_vector));
}
EUFUN_0(Fn_print_counts)
{
PRINT_COUNTS;
return nil;
}
EUFUN_CLOSE
void add_boot_module(LispObject mod)
{
boot_modules[boot_module_count]=mod;
if (static_vectors==NULL)
{
static_vectors=allocate_static_vector(NULL,MAX_MODS); /* NULL is a hack */
statics= &(vref(static_vectors,0));
add_root(&static_vectors);
}
statics[boot_module_count]=mod->C_MODULE.values;
boot_module_count++;
}
EUFUN_0(Fn_boot_module_list)
{
LispObject lst,end;
int i;
lst=EUCALL_2(Fn_cons,nil,nil);
end=lst; /* not gc safe */
for (i=1; i<boot_module_count; i++)
{
LispObject tmp;
tmp=EUCALL_2(Fn_cons,boot_modules[i],nil);
CDR(end)=tmp;
end=tmp;
}
return(lst);
}
EUFUN_CLOSE
EUFUN_2(Fn_set_global,n,val)
{
GLOBAL_REF(intval(n))=val;
return val;
}
EUFUN_CLOSE
#define BCI_ENTRIES 8
#define FIRST_USER_CODE 32
MODULE Module_bci;
LispObject Module_bci_values[BCI_ENTRIES];
void initialise_bci(LispObject *stacktop)
{
int i;
fprintf(stderr,"Bytecodes compiled on: %s\n", MAKE_DATE);
SYSTEM_INITIALISE_GLOBAL(int,static_count,FIRST_USER_CODE);
global_vector=allocate_vector(stacktop,N_GLOBALS);
add_root(&global_vector);
ByteFunction_Class = (LispObject) allocate_class(stacktop,Standard_Class);
add_root(&ByteFunction_Class);
bytevectors=(bytecode **)allocate_space(stacktop,MAX_MODS*sizeof(bytecode *));
make_class(stacktop,ByteFunction_Class,
"bytefunction-class",
Standard_Class,
Funcallable_Object_Class,
0);
ByteFunction = (LispObject) allocate_class(stacktop,ByteFunction_Class);
add_root(&ByteFunction);
make_class(stacktop,ByteFunction,
"bytefunction",
ByteFunction_Class,
Function, N_SLOTS_IN_BYTEFUNCTION);
open_module(stacktop,
&Module_bci,Module_bci_values,"bci",BCI_ENTRIES);
(void) make_module_entry(stacktop,"bytefunction-class",ByteFunction_Class);
(void) make_module_entry(stacktop,"bytefunction",ByteFunction);
(void) make_module_function(stacktop,"add-code-vector",Fn_add_codevector,3);
(void) make_module_function(stacktop,"load-bytecodes",Fn_load_bytecodes,1);
(void) make_module_function(stacktop,"set-module-statics",Fn_set_module_statics,2);
(void) make_module_function(stacktop,"boot-module-list",Fn_boot_module_list,0);
(void) make_module_function(stacktop,"byte-counts",Fn_print_counts,0);
(void) make_module_function(stacktop,"set-bc-global",Fn_set_global,2);
close_module();
bytevectors[0]=exit_bytes;
}
#endif /* BCI */